home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / KERNEL2.SEQ < prev    next >
Text File  |  1988-06-30  |  30KB  |  854 lines
  1. \ KERNEL2.SEQ   More kernel stuff
  2.  
  3. FILES DEFINITIONS
  4.  
  5. VARIABLE KERNEL2.SEQ
  6.  
  7. FORTH DEFINITIONS
  8.  
  9. USER DEFINITIONS
  10. VARIABLE  TOS         ( TOP OF STACK )
  11. VARIABLE  ENTRY       ( ENTRY POINT, CONTAINS MACHINE CODE )
  12. VARIABLE  LINK        ( LINK TO NEXT TASK )
  13. VARIABLE  ES0         ( INITIAL ES: SEGMENT )
  14. VARIABLE  SP0         ( INITIAL PARAMETER STACK )
  15. VARIABLE  RP0         ( INITIAL RETURN STACK )
  16. VARIABLE  DP          ( DICTIONARY POINTER )
  17. VARIABLE  OFFSET      ( RELATIVE TO ABSOLUTE DISK BLOCK 0 )
  18. VARIABLE  BASE        ( FOR NUMERIC INPUT AND OUTPUT )
  19. VARIABLE  HLD         ( POINTS TO LAST CHARACTER HELD IN PAD )
  20. VARIABLE  PRINTING
  21.    DEFER  EMIT
  22.    DEFER  KEY?
  23.    DEFER  KEY
  24.    DEFER  TYPE
  25.    DEFER  EXTYPE
  26.  
  27. META DEFINITIONS
  28. VARIABLE  PRIOR     ( USED FOR DICTIONARY SEARCHES )
  29. VARIABLE  STATE     ( COMPILATION OR INTERPRETATION )
  30. VARIABLE  WARNING   ( GIVE USER DUPLICATE WARNINGS IF ON )
  31. VARIABLE  DPL       ( NUMERIC INPUT PUNCTUATION )
  32. VARIABLE  R#        ( EDITING CURSOR POSITION )
  33. VARIABLE  LAST      ( POINTS TO NFA OF LATEST DEFINITION )
  34. VARIABLE  CSP       ( HOLDS STACK POINTER FOR ERROR CHECKING )
  35. VARIABLE  CURRENT   ( VOCABULARY WHICH GETS DEFINITIONS )
  36. 8 CONSTANT #VOCS    ( THE NUMBER OF VOCABULARIES TO SEARCH )
  37. VARIABLE  CONTEXT   ( VOCABULARY SEARCHED FIRST )
  38.    HERE THERE #VOCS 2* DUP ALLOT ERASE
  39.  
  40. VARIABLE  'TIB      ( ADDRESS OF TERMINAL INPUT BUFFER )
  41. VARIABLE  WIDTH     ( WIDTH OF NAME FIELD )
  42. VARIABLE  VOC-LINK  ( POINTS TO NEWEST VOCABULARY )
  43. VARIABLE  >IN       ( OFFSET INTO INPUT STREAM )
  44. VARIABLE  SPAN      ( NUMBER OF CHARACTERS EXPECTED )
  45. VARIABLE  #TIB      ( NUMBER OF CHARACTERS TO INTERPRET )
  46. VARIABLE  END?      ( TRUE IF INPUT STREAM EXHAUSTED )
  47. VARIABLE  #OUT      ( NUMBER OF CHARACTERS EMITTED )
  48. VARIABLE  #LINE     ( THE NUMBER OF LINES SENT SO FAR )
  49.  
  50. VARIABLE XDP
  51. VARIABLE XDPSEG
  52. VARIABLE YDP            \ HEADER SEG POINTER
  53. VARIABLE YSTART         \ HEAD  START OFFSET
  54. VARIABLE DPSTART        \ LIST  START OFFSET
  55. VARIABLE XSEGLEN
  56. VARIABLE XMOVED         \ FLAG TO TELL IF LIST HAS BEEN MOVED
  57. VARIABLE SSEG           \ SEARCH & SCAN SEGMENT
  58.  
  59. VARIABLE SHNDL          \ the sequential handl POINTER
  60. VARIABLE LOADLINE       \ Offset to line we loaded from
  61. VARIABLE ERRORLINE      \ Last loaded line #
  62.  
  63. 32 CONSTANT BL
  64.  8 CONSTANT BS
  65.  7 CONSTANT BELL
  66.  
  67. VARIABLE CAPS
  68.  
  69. CODE FILL       (  start-addr count char -- )
  70.                 CLD             MOV BX, DS
  71.                 POP AX          POP CX          POP DI
  72.                 PUSH ES         MOV ES, BX
  73.                 REPNZ           STOSB           POP ES
  74.                 NEXT            END-CODE
  75.  
  76. CODE LFILL      (  seg start-addr count char -- )
  77.                 CLD             POP AX          POP CX
  78.                 POP DI          POP BX
  79.                 PUSH ES         MOV ES, BX
  80.                 REPNZ           STOSB           POP ES
  81.                 NEXT            END-CODE
  82.  
  83. : ERASE         ( addr len -- ) 0 FILL   ;
  84. : BLANK         ( addr len -- ) BL FILL   ;
  85.  
  86. CODE COUNT      ( addr -- addr+1 len )
  87.                 POP BX          SUB AX, AX      MOV AL, 0 [BX]
  88.                 INC BX          PUSH BX
  89.                 1PUSH           END-CODE
  90.  
  91. CODE LENGTH     ( addr -- addr+2 len )    \ REALLY WORD COUNT
  92.                 POP BX          MOV AX, 0 [BX]
  93.                 ADD BX, # 2
  94.                 PUSH BX         1PUSH           END-CODE
  95.  
  96. : MOVE          ( from to len -- )
  97.                 -ROT   2DUP U< IF   ROT CMOVE>   ELSE   ROT CMOVE   THEN ;
  98.  
  99. DECIMAL
  100.  
  101. CREATE ATBL     \ Uppercase translation table
  102.  0  C,   1  C,   2  C,   3  C,   4  C,   5  C,   6  C,   7  C,
  103.  8  C,  32  C,  10  C,  11  C,  12  C,  13  C,  14  C,  15  C,
  104. 16  C,  17  C,  18  C,  19  C,  20  C,  21  C,  22  C,  23  C,
  105. 24  C,  25  C,  26  C,  27  C,  28  C,  29  C,  30  C,  31  C,
  106. 32  C,  '!' C,  '"' C,  '#' C,  '$' C,  '%' C,  '&' C,  ''' C,
  107. '(' C,  ')' C,  '*' C,  '+' C,  ',' C,  '-' C,  '.' C,  '/' C,
  108. '0' C,  '1' C,  '2' C,  '3' C,  '4' C,  '5' C,  '6' C,  '7' C,
  109. '8' C,  '9' C,  ':' C,  ';' C,  '<' C,  '=' C,  '>' C,  '?' C,
  110. '@' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  111. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  112. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  113. 'X' C,  'Y' C,  'Z' C,  '[' C,  '\' C,  ']' C,  '^' C,  '_' C,
  114. '`' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  115. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  116. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  117. 'X' C,  'Y' C,  'Z' C,  '{' C,  '|' C,  '}' C,  '~' C,  127 C,
  118. \ Characters above 127 are translated to below 127
  119.  0  C,   1  C,   2  C,   3  C,   4  C,   5  C,   6  C,   7  C,
  120.  8  C,   9  C,  10  C,  11  C,  12  C,  13  C,  14  C,  15  C,
  121. 16  C,  17  C,  18  C,  19  C,  20  C,  21  C,  22  C,  23  C,
  122. 24  C,  25  C,  26  C,  27  C,  28  C,  29  C,  30  C,  31  C,
  123. 32  C,  '!' C,  '"' C,  '#' C,  '$' C,  '%' C,  '&' C,  ''' C,
  124. '(' C,  ')' C,  '*' C,  '+' C,  ',' C,  '-' C,  '.' C,  '/' C,
  125. '0' C,  '1' C,  '2' C,  '3' C,  '4' C,  '5' C,  '6' C,  '7' C,
  126. '8' C,  '9' C,  ':' C,  ';' C,  '<' C,  '=' C,  '>' C,  '?' C,
  127. '@' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  128. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  129. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  130. 'X' C,  'Y' C,  'Z' C,  '[' C,  '\' C,  ']' C,  '^' C,  '_' C,
  131. '`' C,  'A' C,  'B' C,  'C' C,  'D' C,  'E' C,  'F' C,  'G' C,
  132. 'H' C,  'I' C,  'J' C,  'K' C,  'L' C,  'M' C,  'N' C,  'O' C,
  133. 'P' C,  'Q' C,  'R' C,  'S' C,  'T' C,  'U' C,  'V' C,  'W' C,
  134. 'X' C,  'Y' C,  'Z' C,  '{' C,  '|' C,  '}' C,  '~' C,  127 C,
  135.  
  136. CODE UPC        ( char -- char' )
  137.                 POP AX
  138.                 MOV BX, # ATBL
  139.                 XLAT
  140.                 1PUSH
  141.                 END-CODE
  142.  
  143. CODE UPPER      ( addr len -- )         \ convert string to upper case
  144.                         POP CX                  \ get length
  145.                         POP DI                  \ and starting address
  146. LABEL >UPPER+2          PUSH SI                 \ save IP
  147.                         MOV DX, ES              \ and LIST POINTER
  148.                         MOV BX, DS
  149.                         MOV ES, BX              \ set ES to DS
  150.                         MOV SI, DI              \ set SI to DI
  151.                         MOV BX, # ATBL          \ loadup BX with table
  152.                         CLD                     \ clear direction flag
  153.               CX<>0 IF
  154.                         HERE                    \ get a char and traslate it
  155.                                 LODSB   XLAT
  156.                                 STOSB
  157.                         LOOPNZ                  \ until all chars are done
  158.                     THEN
  159.                         MOV ES, DX              \ restore ES=LIST
  160.                         POP SI                  \     and SI=IP
  161.                         NEXT    END-CODE
  162.  
  163. \ : ?UPPERCASE    ( adr -- adr )
  164. \                 CAPS @ IF  DUP COUNT UPPER   THEN  ;
  165.  
  166. CODE ?UPPERCASE ( A1 --- A1 )           \ conditionally convert to upper case
  167.                 MOV CX, CAPS                    \ test CAPS variable
  168.   CX<>0 IF                                      \ leave if CAPS is not on
  169.                 POP DI          PUSH DI         \ get a copy of address a1
  170.                 SUB CX, CX      MOV CL, 0 [DI]
  171.                 INC DI                          \ Addr and Cnt in DI & CX
  172.                 JMP >UPPER+2                    \ go translate to upper case
  173.         THEN
  174.                 NEXT
  175.                 END-CODE
  176.  
  177. CODE HERE       ( -- adr )
  178.                 MOV BX, UP      MOV AX, DP [BX]
  179.                 1PUSH           END-CODE
  180.  
  181. \ : PAD           ( -- addr ) HERE 80 +   ;
  182.  
  183. CODE PAD        ( -- adr )
  184.                 MOV BX, UP
  185.                 MOV AX, DP [BX]
  186.                 ADD AX, # 80
  187.                 1PUSH           END-CODE
  188.  
  189. \ : -TRAILING     ( addr len -- addr len' )
  190. \                 DUP 0 ?DO   2DUP + 1- C@   BL <> ?LEAVE   1-   LOOP   ;
  191.  
  192. CODE -TRAILING  ( addr len -- addr1 len1 )
  193.                 POP BX
  194.                 POP DI
  195.                 MOV AL, # 32
  196.                 BEGIN
  197.                         CMP -1 [DI+BX], AL
  198.                      0= IF      2SWAP           \ compile time correction
  199.                                 DEC BX
  200.              0= UNTIL
  201.                         THEN
  202.                 PUSH DI
  203.                 PUSH BX
  204.                 NEXT            END-CODE
  205.  
  206. CODE COMP       ( addr1 addr2 len -- -1 | 0 | 1 )
  207.                 MOV DX, SI      POP CX
  208.                 POP DI          POP SI
  209.   CX<>0 IF
  210.                 PUSH ES         MOV ES, SSEG
  211.                 REPZ            CMPSB
  212.         0<> IF
  213. LABEL COMPX  0< IF
  214.                    MOV CX, # -1
  215.                 ELSE
  216.                    MOV CX, # 1
  217.                 THEN
  218.             THEN
  219.         THEN
  220. LABEL NOMORE    MOV SI, DX
  221.                 POP ES
  222.                 PUSH CX
  223.                 NEXT            END-CODE
  224.  
  225. HEX
  226.  
  227. CODE CAPS-COMP  ( addr1 addr2 len -- -1 | 0 | 1 )
  228.                 MOV DX, SI      POP CX
  229.                 POP DI          POP SI
  230.                 PUSH ES         MOV ES, SSEG
  231.             BEGIN
  232.                 JCXZ NOMORE
  233.                 MOV     AH, 0 [SI]      INC SI
  234.                 MOV ES: AL, 0 [DI]      INC DI
  235.                 OR AX, # 2020           CMP AH, AL
  236.                 JNE COMPX               DEC CX
  237.             AGAIN
  238.                 END-CODE
  239.  
  240. DECIMAL
  241.  
  242. : COMPARE       ( addr1 addr2 len -- -1 | 0 | 1 )
  243.                 CAPS @ IF   CAPS-COMP   ELSE   COMP   THEN   ;
  244.  
  245. VARIABLE OSF
  246.  
  247. LABEL FCDOS     PUSH SI         PUSH BP
  248.                 INC CS: OSF WORD
  249.                 INT 33
  250.                 DEC CS: OSF WORD
  251.                 POP BP          POP SI
  252.                 RET             END-CODE
  253.  
  254. CODE XFDOS      ( DX CX BX AX ES DS-CX BX AX CY)
  255.                 POP DI          POP DS          POP AX
  256.                 POP BX          POP CX          POP DX
  257.                 PUSH ES         PUSH DS         POP ES
  258.                 PUSH CS
  259.                 MOV DS, DI      CALL FCDOS
  260.                 POP DS          POP ES          MOV DX, # -1
  261.             U>= IF
  262.                 XOR DX, DX
  263.             THEN
  264.                 PUSH CX         PUSH BX
  265.                 PUSH AX         PUSH DX
  266.                 NEXT            END-CODE
  267.  
  268. CODE ?CS:       ( -- CS )
  269.                 PUSH CS         NEXT            END-CODE
  270.  
  271. CODE ?ES:       ( -- CS )
  272.                 PUSH ES         NEXT            END-CODE
  273.  
  274. CODE @L         ( seg addr --- word )
  275.                 POP BX          POP DS          MOV AX, 0 [BX]
  276.                 MOV BX, CS      MOV DS, BX
  277.                 1PUSH           END-CODE
  278.  
  279. CODE C@L        ( seg addr --- byte )
  280.                 POP BX          POP DS          MOV AL, 0 [BX]
  281.                 XOR AH, AH      MOV BX, CS      MOV DS, BX
  282.                 1PUSH           END-CODE
  283.  
  284. CODE C!L        ( byt seg adr )
  285.                 POP BX          POP DS          POP AX
  286.                 MOV 0 [BX], AL  MOV BX, CS      MOV DS, BX
  287.                 NEXT            END-CODE
  288.  
  289. CODE !L         ( n seg adr -- )
  290.                 POP BX          POP DS          POP AX
  291.                 MOV 0 [BX], AX  MOV BX, CS      MOV DS, BX
  292.                 NEXT            END-CODE
  293.  
  294. CODE <BDOS>     ( n fun -- m )
  295.                 POP AX          MOV AH, AL      POP DX
  296.                 INT 33          SUB AH, AH
  297.                 1PUSH           END-CODE
  298.  
  299. DEFER BDOS      ' <BDOS> IS BDOS
  300.  
  301. CODE BDOS2      ( CX DX AX -- CX DX AX )
  302.                 POP AX          POP DX          POP CX
  303.                 MOV AH, AL      INT 33
  304.                 PUSH CX         PUSH DX         PUSH AX
  305.                 NEXT            END-CODE
  306.  
  307. : OS2           BDOS2 255 AND ;
  308.  
  309. HEX
  310.  
  311. VARIABLE BIOSCHAR       \ Holds the char from BIOS on scan by BIOSKEY?
  312. VARIABLE BIOSKEYVAL     \ Holds the key value from BIOSKEY
  313.  
  314. CODE BIOSKEY?   ( --- f1 )
  315.         BEGIN
  316.                 MOV AH, # 1
  317.                 INT 16
  318.                 MOV BIOSCHAR AX
  319.           0= IF
  320.                 MOV AX, # 0
  321.                 1PUSH
  322.              THEN
  323.                 CMP AX, # 0     \ Ignore Control Break keys
  324.      0= WHILE
  325.                 MOV AH, # 0     \ That is throw them away
  326.                 INT 16
  327.         REPEAT
  328.                 MOV AX, # -1
  329.                 1PUSH           END-CODE
  330.  
  331. CODE BIOSKEY    ( --- c1 )
  332.         BEGIN
  333.                 MOV AH, # 0
  334.                 INT 16
  335.                 CMP AX, # 0             \ Ignore Control BREAK, 00 Hex.
  336.     0<> UNTIL
  337.                 MOV BIOSKEYVAL AX
  338.                 1PUSH           END-CODE
  339.  
  340. DECIMAL
  341.  
  342. DEFER KEYFILTER ' NOOP IS KEYFILTER     \ Pre-filter keys before passing on.
  343.  
  344. DEFER BGSTUFF   ' NOOP IS BGSTUFF       \ BACKGROUND STUFF
  345.  
  346. : (KEY?)        ( -- f )
  347.                 BGSTUFF BIOSKEY? ;
  348.  
  349. : (KEY)         ( -- CHAR )
  350.                 BEGIN   PAUSE KEY? UNTIL
  351.                 BIOSKEY DUP 127 AND 0=
  352.                 IF      FLIP 127 AND 128 OR
  353.                 ELSE    127 AND
  354.                 THEN    KEYFILTER ;
  355.  
  356. DEFER OUTPAUSE  ( ' PAUSE ) ' NOOP IS OUTPAUSE
  357. DEFER CONSOLE
  358.  
  359. CODE CMOVEL     ( sseg sptr dseg dptr cnt )
  360.                 CLD             MOV BX, SI
  361.                 POP CX          POP DI
  362.                 POP AX          POP SI
  363.                 POP DS          PUSH ES         MOV ES, AX
  364.                 OR CX, CX
  365.             0<> IF
  366.                 REPNZ           MOVSB
  367.             THEN
  368.                 POP ES
  369.                 MOV AX, CS      MOV DS, AX
  370.                 MOV SI, BX
  371.                 NEXT            END-CODE
  372.  
  373. CODE CMOVEL>    ( sseg sptr dseg dptr cnt )
  374.                 STD             MOV BX, SI
  375.                 POP CX          POP DI
  376.                 POP AX          POP SI
  377.                 POP DS          PUSH ES         MOV ES, AX
  378.                 OR CX, CX
  379.             0<> IF
  380.                 DEC CX          ADD DI, CX
  381.                 ADD SI, CX      INC CX
  382.                 REPNZ           MOVSB
  383.             THEN
  384.                 POP ES
  385.                 MOV AX, CS      MOV DS, AX
  386.                 MOV SI, BX
  387.                 CLD
  388.                 NEXT            END-CODE
  389.  
  390. HEX
  391. 1000 CONSTANT #CODESEGS \ Number of segments needed for CODE.  64k
  392. 1000 CONSTANT #LISTSEGS \ Number of segments needed for : definitions. 64k
  393. 1000 CONSTANT #HEADSEGS \ Number of segments needed for HEADS. 64K
  394.  
  395. DECIMAL
  396.  
  397.  
  398. : MEMCHK        ( F1 --- )
  399.                 IF      ." Insufficient Memory"
  400.                         0 0 BDOS
  401.                 THEN ;
  402.  
  403. HEX
  404.  
  405. CODE DEALLOC    ( N1 -- F1 ) \ N1 = BLOCK TO DE-ALLOCATE, F1 = 0 IS OK
  406.                 MOV AH, # 49 \ F1 = 9 INVALID BLOCK ADDRESS
  407.                 POP DX
  408.                 PUSH ES         MOV ES, DX      INT 21
  409.              u< if
  410.                 sub ah, ah
  411.              else
  412.                 mov ax, # 0
  413.              then
  414.                 POP ES          1PUSH           END-CODE
  415.  
  416. CODE ALLOC      ( N1 -- N2 N3 F1 )      \ N1 = SIZE NEEDED, N3 = SEGMENT
  417.                                         \ N2 = LARGEST SEGMENT AVAILABLE
  418.                 MOV AH, # 48            \ F1 = 8 NOT ENOUGH MEMORY.
  419.                 POP BX
  420.                 INT 21
  421.                 PUSH BX         PUSH AX
  422.              u< if
  423.                 sub ah, ah
  424.              else
  425.                 mov ax, # 0
  426.              then
  427.                 1PUSH           END-CODE
  428.  
  429. : MEMSET        ( N1 --- F1 )
  430.                 0 0 ROT 4A00 ?CS: DUP XFDOS >R 3DROP R> ;
  431.  
  432. : DOSVER        0 30 BDOS 0FF AND ;
  433.  
  434. DEFER CURSORSET ' NOOP IS CURSORSET
  435.  
  436. : SETYSEG       ( --- )   \ SETS HEAD SEGMENT + MORE SPACE
  437.                 [ LABEL 'SETYSEG ]
  438.                 ?CS: SSEG !
  439.                 ?CS: TYPESEG !
  440.                 XSEGLEN @ XSEG @ + XDPSEG !
  441.                 XDP OFF
  442.                 DPSTART @ DP !
  443.                 DOSVER 2 <
  444.                 IF      ." Must have DOS 2.x or higher, prefer 3.x"
  445.                         0 0 BDOS
  446.                 THEN
  447.                 #CODESEGS #LISTSEGS + #HEADSEGS + MEMSET MEMCHK
  448.                 #OUT 0! 18 ( 24 DECIMAL ) #LINE !
  449.                 CURSORSET ;
  450.  
  451. DECIMAL
  452.  
  453. CODE YHERE      ( -- adr )
  454.                 MOV AX, YDP
  455.                 1PUSH           END-CODE
  456.  
  457. CODE YS:        ( W -- YSEG W )
  458.                 POP AX          MOV DX, YSEG
  459.                 2PUSH           END-CODE
  460.  
  461. : YC@           ( yaddr -- char ) YS: C@L ;
  462. : YC!           ( yaddr -- char ) YS: C!L ;
  463. : Y@            ( ad -- n )       YS: @L ;
  464. : Y!            ( n yaddr -- )    YS: !L ;
  465. : Y,            ( n -- )          YHERE Y!  2 YDP +! ;
  466. : YCSET         ( byte yaddr -- ) TUCK YC@ OR SWAP YC! ;
  467. : YHASH         ( ystr vocaddr -- thread )
  468.                 SWAP
  469.                 DUP YC@ SWAP 1+ YC@ +
  470.                 #THREADS 1- AND 2* + ;
  471.  
  472. CODE XHERE      ( -- seg adr )
  473.                 MOV AX, XDP
  474.                 MOV DX, XDPSEG
  475.                 2PUSH           END-CODE
  476.  
  477. CODE X,         ( n -- )        \ XHERE !L  2 XDP +!
  478.                 POP AX
  479.                 MOV CS: BX, XDP
  480.                 MOV DS, XDPSEG
  481.                 MOV 0 [BX], AX
  482.                 MOV BX, CS
  483.                 MOV DS, BX
  484.                 ADD XDP # 2 WORD
  485.                 NEXT            END-CODE
  486.  
  487. CODE XC,        ( n -- )        \ XHERE C!L 1 XDP +!
  488.                 POP AX
  489.                 MOV CS: BX, XDP
  490.                 MOV DS, XDPSEG
  491.                 MOV 0 [BX], AL
  492.                 MOV BX, CS
  493.                 MOV DS, BX
  494.                 INC XDP WORD
  495.                 NEXT            END-CODE
  496.  
  497. CODE PR-STATUS  ( N1 --- F1 )
  498.                 POP DX          \ PRINTER NUMBER
  499.                 MOV AH, # 2
  500.                 PUSH SI         PUSH BP
  501.                 INT 23          POP BP
  502.                 POP SI          MOV AL, AH
  503.                 MOV AH, # 0
  504.                 1PUSH           END-CODE
  505.  
  506. HEX
  507.                 \ 90 is printer not busy & printer selected.
  508. : <?PTR.READY> ( --- F1 )     0 PR-STATUS ( 90 AND ) 90 = ;
  509.  
  510. DEFER ?PRINTER.READY    ' <?PTR.READY> IS ?PRINTER.READY
  511.  
  512. DECIMAL
  513.  
  514. DEFER CR
  515. DEFER PEMIT     \ ' (PRINT) IS PEMIT
  516.  
  517. : (EMIT)        ( char -- )
  518.                 PRINTING @ IF DUP PEMIT #OUT DECR THEN CONSOLE ;
  519.  
  520. : CRLF          ( -- )
  521.                 13 EMIT 10 EMIT #OUT OFF
  522.                 #LINE DUP @ 1+
  523.                 PRINTING @ 0=
  524.                 IF      24 MIN  THEN SWAP ! ;
  525.  
  526. \ : (TYPE)        ( addr len -- ) 0 ?DO  COUNT EMIT LOOP DROP ;
  527.  
  528. : FEMIT         ( C1 --- ) SP@ 1 TYPE DROP ;
  529.  
  530. : SPACE         ( -- )    BL EMIT ;
  531.  
  532. CREATE SPCS     ( --- A1 )      \ An array of 80 spaces for use by SPACES
  533. HEX             2020
  534.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  535.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  536.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  537.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP ,
  538.                 DUP , DUP , DUP , DUP , DUP , DUP , DUP ,     ,
  539. DECIMAL
  540.  
  541. : SPACES        ( N --- )
  542.                 SPCS SWAP 80 MIN 0 MAX TYPE ;
  543.  
  544. : BACKSPACES    ( n -- )  0 ?DO   BS EMIT -2 #OUT +! LOOP  ;
  545.  
  546. : BEEP          ( -- )    BELL (EMIT) #OUT DECR ;
  547.  
  548. : BS-IN         ( n c -- 0 | n-1 )
  549.                 >R DUP
  550.                 IF      1-   BS
  551.                 ELSE    BELL
  552.                 THEN    EMIT #OUT DUP @ 2- 0 MAX SWAP ! R> ;
  553.  
  554. : (DEL-IN)      ( n c -- 0 | n-1 )
  555.                 >R DUP
  556.                 IF      1-  #OUT @ BS EMIT SPACE #OUT ! BS
  557.                 ELSE    BELL
  558.                 THEN    EMIT #OUT DUP @ 2- 0 MAX SWAP ! R> ;
  559.  
  560. DEFER DEL-IN    ' (DEL-IN) IS DEL-IN
  561.  
  562. : BACK-UP       ( n c -- 0 c )
  563.                 >R DUP BACKSPACES   DUP SPACES   BACKSPACES   0  R> ;
  564.  
  565. : RESET-IN      ( c -- ) FORTH   TRUE ABORT" Reset"  ;
  566.  
  567. DEFER RES-IN    ' RESET-IN IS RES-IN
  568.  
  569. : P-IN          ( c -- c ) PRINTING @ 0= PRINTING !  ;
  570.  
  571. : (ESC-IN)      ( C -- ) >R 2DUP + @ EMIT 1+ R> ;
  572.  
  573. DEFER ESC-IN    ' (ESC-IN) IS ESC-IN
  574.  
  575. : CR-IN         ( m a n c -- m a m C )
  576.                 >R SPAN !   OVER   BL EMIT R>  ;
  577.  
  578. : (CHAR)        ( a n char -- a n+1 CHAR )
  579.                 DUP >R 3DUP EMIT + C!   1+  R> ;
  580.  
  581. DEFER CHAR      ' (CHAR) IS CHAR
  582. DEFER ^CHAR     ' CHAR   IS ^CHAR
  583.  
  584. : NORM-KEYTABLE
  585.                EXEC:
  586.    ^CHAR   ^CHAR  ^CHAR  RES-IN ^CHAR  ^CHAR   ^CHAR  ^CHAR
  587.    DEL-IN  ^CHAR  ^CHAR  ^CHAR  ^CHAR  CR-IN   ^CHAR  ^CHAR
  588.    P-IN    ^CHAR  ^CHAR  ^CHAR  ^CHAR  BACK-UP ^CHAR  ^CHAR
  589.    BACK-UP ^CHAR  ^CHAR  ESC-IN ^CHAR  ^CHAR   ^CHAR  ^CHAR ;
  590.  
  591. DEFER KEYTABLE  ' NORM-KEYTABLE IS KEYTABLE
  592.  
  593.                 \ expect to a buffer that may already contain some data.
  594. : NEXPECT       ( ADR LEN START -- )
  595.                 DUP >R IF OVER R@ TYPE THEN
  596.                 DUP SPAN !   SWAP R> ( LEN ADR 0_SOFAR )
  597.                 BEGIN   2 PICK OVER - ( len adr #so-far #left )
  598.                 WHILE   KEY DUP BL <
  599.                         IF      DUP KEYTABLE DROP
  600.                         ELSE    DUP 127 =
  601.                                 IF   DEL-IN   ELSE   CHAR   THEN  DROP
  602.                         THEN
  603.                 REPEAT  3DROP ;
  604.  
  605. : EXPECT        ( adr len -- )
  606.                 0   NEXPECT  ;          ( len adr 0 )
  607.  
  608.  
  609. : TIB           ( -- adr )      'TIB @  ;
  610.  
  611. : QUERY         ( -- )          TIB 80 EXPECT  SPAN @ #TIB ! >IN OFF  ;
  612.  
  613.       VARIABLE DISK-ERROR
  614.    -2 CONSTANT LIMIT
  615.  
  616. LIMIT 10 - CONSTANT FIRST
  617. FIRST 10 - CONSTANT INIT-R0
  618.  
  619. DECIMAL
  620.  
  621. FORTH DEFINITIONS
  622.  
  623. : HEX           ( -- )   16 BASE !  ;
  624. : DECIMAL       ( -- )   10 BASE !  ;
  625. : OCTAL         ( -- )    8 BASE !  ;
  626.  
  627. DEFER DEFAULT
  628.  
  629. LABEL FAIL      SUB AX, AX      1PUSH           END-CODE
  630.  
  631. CODE DIGIT      ( char base -- n f )
  632.                 POP DX          POP AX          PUSH AX
  633.                 SUB AL, # ASCII 0
  634.                 JB FAIL         CMP AL, # 9
  635.               > IF
  636.                 CMP AL, # 17    JB FAIL         SUB AL, # 7
  637.               THEN
  638.                 CMP AL, DL
  639.                 JAE FAIL
  640.                 MOV DL, AL      POP AX          MOV AX, # TRUE
  641.                 2PUSH           END-CODE
  642.  
  643. : DOUBLE?       ( -- f ) DPL @ 1+   0<> ;
  644.  
  645. : CONVERT       ( +d1 adr1 -- +d2 adr2 )
  646.                 BEGIN   1+  DUP >R  C@  BASE @  DIGIT
  647.                 WHILE   SWAP  BASE @ UM*  DROP  ROT  BASE @ UM*  D+
  648.                         DOUBLE?  IF  DPL INCR THEN  R>
  649.                 REPEAT  DROP  R>  ;
  650.  
  651. : (NUMBER?)     ( adr -- d flag )
  652.                 0 0  ROT  DUP 1+  C@  ASCII -  =  DUP  >R  -  DPL -1!
  653.                 BEGIN   CONVERT  DUP C@  ASCII , ASCII / BETWEEN
  654.                 WHILE   DPL 0!
  655.                 REPEAT  -ROT  R> IF  DNEGATE  THEN   ROT C@ BL =  ;
  656.  
  657. : NUMBER?       ( adr -- d flag )
  658.                 FALSE  OVER COUNT BOUNDS
  659.                 ?DO     I C@ BASE @ DIGIT NIP
  660.                         IF      DROP TRUE LEAVE THEN
  661.                 LOOP
  662.                 IF  (NUMBER?)  ELSE  DROP  0 0 FALSE  THEN  ;
  663.  
  664. \ : (NUMBER)      ( adr -- d# ) NUMBER? NOT ?MISSING  ;
  665.  
  666. comment:
  667.  
  668.   A simple word to make Forth accept numbers prefixed with $ as Hex
  669. numbers.
  670.  
  671. comment;
  672.  
  673. CODE +1=$?      ( A1 --- A1 F1 )        \ is second char in a1 a $ ?
  674.                 POP BX
  675.                 PUSH BX
  676.                 MOV AL, 1 [BX]
  677.                 CMP AL, # ASCII $
  678.             0<> IF
  679.                         SUB AX, AX
  680.                 THEN
  681.                 1PUSH
  682.                 END-CODE
  683.  
  684. CODE +1='?      ( A1 --- A1 F1 )        \ is second char in a1 a $ ?
  685.                 POP BX
  686.                 PUSH BX
  687.                 MOV AL, 1 [BX]
  688.                 CMP AL, # ASCII '
  689.             0<> IF
  690.                         SUB AX, AX
  691.                 THEN
  692.                 1PUSH
  693.                 END-CODE
  694.  
  695. : (NUMBER)      ( A1 --- D1 )           \ Prefix with $ for auto HEX base.
  696.                 +1=$?                     \ $ is for HEX
  697.                 IF      DUP >R DUP COUNT 1- 0 MAX >R
  698.                         DUP 1+ SWAP R> CMOVE    \ Extract the $.
  699.                         DUP C@ 1- OVER C!       \ Shorten count by 1.
  700.                         BL OVER COUNT + C!      \ Append a blank to string.
  701.                         BASE @ >R       \ Save the base for later restoral.
  702.                         HEX NUMBER?     \ Try to convert the number in HEX
  703.                         R> BASE !       \ Restore the BASE.
  704.                         DUP 0=          \ If its not a number, restore the $.
  705.                         IF      R@ COUNT >R DUP 1+ R> CMOVE>
  706.                                 R@ C@ 1+ R@ C!
  707.                                 ASCII $ R@ 1+ C!
  708.                         THEN    r>drop
  709.                 ELSE    +1='?                   \ recognize ' for ascii
  710.                         IF      2+ C@ 0 TRUE
  711.                                 DPL ON
  712.                         ELSE    NUMBER?
  713.                         THEN
  714.                 THEN
  715.                 NOT ?MISSING ;
  716.  
  717. DEFER NUMBER
  718.  
  719. : HOLD          ( char -- )
  720.                 HLD DECR HLD @ C!   ;
  721.  
  722. : <#            ( -- )  PAD  HLD  !  ;
  723.  
  724. : #>            ( d# -- addr len )
  725.                 2DROP  HLD  @  PAD  OVER  -  ;
  726.  
  727. : SIGN          ( n1 -- )
  728.                 0< IF  ASCII -  HOLD  THEN  ;
  729.  
  730. : #             ( -- )
  731.                 BASE @ MU/MOD ROT 9 OVER <
  732.                 IF  7 + THEN ASCII 0  +  HOLD  ;
  733.  
  734. : #S            ( -- )
  735.                 BEGIN  #  2DUP  OR  0=  UNTIL  ;
  736.  
  737. : (U.)          ( u -- a l )    0    <# #S #>   ;
  738. : U.            ( u -- )        (U.)   TYPE SPACE   ;
  739. : U.R           ( u l -- )      >R   (U.)   R> OVER - SPACES   TYPE   ;
  740.  
  741. : (.)           ( n -- a l )    DUP ABS 0   <# #S   ROT SIGN   #>   ;
  742. : .             ( n -- )        (.)   TYPE SPACE   ;
  743. : .R            ( n l -- )      >R   (.)   R> OVER - SPACES   TYPE   ;
  744.  
  745. : (UD.)         ( ud -- a l )   <# #S #>   ;
  746. : UD.           ( ud -- )       (UD.)   TYPE SPACE   ;
  747. : UD.R          ( ud l -- )     >R   (UD.)   R> OVER - SPACES   TYPE  ;
  748.  
  749. : (D.)          ( d -- a l )    TUCK DABS   <# #S   ROT SIGN  #>   ;
  750. : D.            ( d -- )        (D.)   TYPE SPACE   ;
  751. : D.R           ( d l -- )      >R   (D.)   R> OVER - SPACES   TYPE   ;
  752.  
  753. LABEL DONE
  754.                 PUSH CX         NEXT            END-CODE
  755.  
  756. CODE  SKIP      ( addr len char -- addr' len' )
  757.                 POP AX          POP CX
  758.                 JCXZ DONE
  759.                 POP DI          PUSH ES         MOV ES, SSEG
  760.                 REPZ            SCASB           POP ES
  761.             0<> IF
  762.                 INC CX          DEC DI
  763.             THEN
  764.                 PUSH DI         PUSH CX
  765.                 NEXT            END-CODE
  766.  
  767. CODE  SCAN      ( addr len char -- addr' len' )
  768.                 POP AX          POP CX
  769.                 JCXZ DONE
  770.                 POP DI          PUSH ES
  771.                 MOV ES, SSEG    MOV BX, CX
  772.                 REPNZ           SCASB           POP ES
  773.              0= IF
  774.                 INC CX          DEC DI
  775.              THEN
  776.                 PUSH DI         PUSH CX
  777.                 NEXT            END-CODE
  778.  
  779. CODE /STRING    ( addr len n -- addr' len' )
  780.                 POP AX          POP BX
  781.                 PUSH BX         CMP BX, AX
  782.             U<= IF
  783.                 XCHG BX, AX     \ AX = SMALLER OF AX BX
  784.              THEN
  785.                 POP BX          POP DX
  786.                 ADD DX, AX      PUSH DX
  787.                 SUB BX, AX      PUSH BX
  788.                 NEXT            END-CODE
  789.  
  790. CODE PARSE-WRD  ( C1 A1 N1 --- A2 N2 )
  791.                 POP CX          POP DX          POP BX
  792.                 PUSH ES                         \ Save ES for later restoral
  793.                 PUSH CX         MOV AX, >IN
  794.                 CMP CX, AX
  795.             U<= IF
  796.                 MOV AX, CX      \ AX = SMALLER OF AX CX
  797.              THEN
  798.                 ADD DX, AX      PUSH DX         SUB CX, AX
  799.                 MOV AX, BX
  800.           CX<>0 IF
  801.                 POP DI          MOV DX, DS      MOV ES, DX
  802.                 REPZ            SCASB
  803.                 0<> IF
  804.                         INC CX  DEC DI
  805.                     THEN
  806.                 PUSH DI
  807.            THEN
  808.                 POP AX          PUSH AX         PUSH AX
  809.                 MOV AX, BX
  810.           CX<>0 IF
  811.                 POP DI
  812.                 REPNZ           SCASB
  813.                 0= IF
  814.                         INC CX  DEC DI
  815.                    THEN
  816.                 PUSH DI
  817.            THEN
  818.                 POP AX          POP DX          SUB AX, DX      POP BX
  819.                 POP ES                          \ Restore ES
  820.                 PUSH DX         PUSH AX
  821.           CX<>0 IF
  822.                 DEC CX
  823.             THEN
  824.                 SUB BX, CX      MOV >IN BX      NEXT            END-CODE
  825.  
  826. CODE SOURCE     ( -- addr len )         \ TIB #TIB @
  827.                 MOV DX, 'TIB
  828.                 MOV AX, #TIB
  829.                 2PUSH
  830.                 END-CODE
  831.  
  832. : PARSE         ( char -- addr len )
  833.                 >R   SOURCE >IN @ /STRING   OVER SWAP R> SCAN
  834.                 >R OVER -  DUP R>  0<> -  >IN +!  ;
  835.  
  836. DEFER 'WORD     ( -- adr )     ' HERE IS 'WORD
  837.  
  838. CODE PLACE-SUFIX.BL     ( from cnt to -- to )
  839.                 POP DX          MOV DI, DX
  840.                 POP CX          MOV 0 [DI], CL
  841.                 INC DI          CLD
  842.                 MOV BX, IP      MOV AX, DS
  843.                 POP IP
  844.                 PUSH ES         MOV ES, AX
  845.                 REPNZ           MOVSB
  846.                 MOV AL, # 32    STOSB
  847.                 MOV IP, BX      POP ES          PUSH DX
  848.                 NEXT            END-CODE
  849.  
  850. : WORD          ( char -- addr )
  851.                 SOURCE PARSE-WRD 'WORD PLACE-SUFIX.BL ;
  852.  
  853.  
  854.